
package Sgdb::Utils ;           # this is NOT really a base object, this is a shared object

use warnings ;
use strict ;
use integer ;
use bytes ;

use Tk 'Ev' ;
$Tk::encodeFallback = 1 ;       # so simple, so helpful

use Sgdb::LocalConfig ;

use Exporter ();
our @ISA = 'Exporter' ;
our @EXPORT = qw( $mainwindow
                  busy
                  unbusy
                  pref
                  pref_set
                  pref_image
                  telme
                  telthem
                  telthemloud
                  askthem
                  runlocked
                  hook_add
                  hook_run
                  hook_run_lock
                  hook_remove
                  pref_reconfigure
                  gdb_exec
                  gdb_exec_quiet
                  gdb_exec_hist
                  gdb_exec_lock
                  gdb_cached
                  balloonset
                  args
                  find_file
                  bindkey
                  focus_on
                  istkwidget
                  pref_tags
                  menu_fill
                  iff
                  text_current_word
                  );
#                   $remotegui

our @EXPORT_OK = qw ( get_full_filename
                      menu_pop_common_View
                      menu_pop_common_Edit
                      menu_pop_NB_Raise
                      save_Text_data_as
                      bind_search_mechanism
                      bind_history_mechanism
                      bind_font_resize
                      tab_complete_filename
                      tab_complete_gdb_command
                      tracepoints_list
                      breakpoints_list
                      args_set
                      bypass_busy_for_interrupter
                      isbusy
                      recursive_mkdir
                      recursive_clean_dir
                      localconfig
                      getfilename
                      info_line_lookup
                      get_scratch_directory
                      create_window
                      window_geometry
                      please_close_me
                      set_recent
                      get_recent
                      callbacker
                      array_eq
                      dotsgdbfile
                      $slc_cred $slc_pass slc_weekly
                      tellog
                      http_get
                      gdb_sources
                      gdb_source_map
                      gdb_func_map
                      change_font_size
                      target_symmetrix_list
                      target_symmetrix_chdir
                      foreach_target_symmetrix
                      get_a2l
                    ) ;

my $arguments = '' ;
our $mainwindow ;

# Perlon: the 'right' way to create sub aliases is:
#  *pref = \&Sgdb::Preferences::prefered ; # (TIMTOWTDI)

sub pref                    { &Sgdb::Preferences::ex_pref                  }
sub pref_set                { &Sgdb::Preferences::ex_pref_set              }
sub pref_reconfigure        { &Sgdb::Preferences::ex_pref_reconfigure      }
sub dotsgdbfile             { &Sgdb::Preferences::ex_dotsgdbfile           }
sub bindkey                 { &Sgdb::Preferences::ex_bindkey               }
sub change_font_size        { &Sgdb::Preferences::ex_change_font_size      }
sub pref_image              { &Sgdb::myImages::ex_pref_image               }
sub gdb_exec                { &Sgdb::CommandPrompt::ex_gdb_exec            }
sub gdb_exec_quiet          { &Sgdb::CommandPrompt::ex_gdb_exec_quiet      }
sub gdb_exec_hist           { &Sgdb::CommandPrompt::ex_gdb_exec_hist       }
sub gdb_cached              { &Sgdb::CommandPrompt::ex_gdb_cached          }
sub gdb_sources             { &Sgdb::CommandPrompt::ex_gdb_sources         }
sub gdb_source_map          { &Sgdb::CommandPrompt::ex_gdb_source_map      }
sub gdb_func_map            { &Sgdb::CommandPrompt::ex_gdb_func_map        }
sub target_symmetrix_list   { &Sgdb::CommandPrompt::ex_target_symmetrix_list }
sub target_symmetrix_chdir  { &Sgdb::CommandPrompt::ex_target_symmetrix_chdir}
sub tracepoints_list        { &Sgdb::DataTracepoints::ex_tracepoints_list  }
sub breakpoints_list        { &Sgdb::DataBreakpoints::ex_breakpoints_list  }
sub balloonset              { &Sgdb::StatusLine::ex_balloonset             }
sub localconfig             { &Sgdb::LocalConfig::local_config             }
sub get_scratch_directory   { &Sgdb::ServicePane::scratch_directory        }

my  $isbusy ;
sub unbusy                  { $isbusy = 0; $mainwindow -> Unbusy ( -recurse => 1 ); 1}
sub busy                    { $mainwindow -> Busy ( -recurse => 1 )  ;    $isbusy = 1}
sub isbusy                  { $isbusy }

sub foreach_target_symmetrix(&;$) { &Sgdb::CommandPrompt::ex_foreach_target_symmetrix }

sub telme ;
sub telthemloud ;
sub hook_run ;

use File::Basename ;
sub recursive_mkdir($) {

    # Perlon: shall we use File::Path ? or is it simple enough 'as is' ?
    my $dir = shift ;
    unless (-d $dir) {
        my @td = split /\/|\\/, $dir ;
        my $td = $td[0] =~ /^[a-z]\:$/i? shift @td : '' ;
        while ( @td) {
            $td .= '/' . shift @td ;
            mkdir $td unless -d $td ;
        }
        return unless -d $dir;
    }
    $dir
}

sub recursive_clean_dir {

    my $dir = shift ;
    for ( glob "$dir/*" ) {
        if ( -d ) {
            recursive_clean_dir ($_ ) ;
            rmdir ;
        }
        elsif ( -f ) {
            unlink ;
        }
        eval { telthem $! if $! } ;
    }
}

sub istkwidget($) {
    my $widget = shift or return ;
    ref $widget or return ;
    eval { $widget -> Exists () } and $widget ;
}

sub pref_tags($$@) {
    my ($t, $name, @tags) = @_ ;
    for my $tag (@tags) {
        $t -> tagConfigure( $tag, pref "$name-$tag-tag") ;
    }
    $t -> tagRaise ( 'sel' ) ;
    $t
}

sub menu_fill($$@) {
    my $menu = shift ;
    my $pref = shift ;
    my $sm = $menu ;
    for (@_){
        my $r = ref ;
        if (not $r){
            if ($_ eq '-') {
                $sm -> add('separator') if $sm ;
            }
            elsif ($_ eq '--') {
                $sm = $menu ;
            }
            elsif ($_ eq '---') {
                $sm = $menu ;
                $sm -> add ('separator') ;
            }
            elsif (defined $menu -> FindName( $_ )) {
                $sm = $menu -> entrycget( $sm, '-menu') ;
            }
            else {
                $sm = $menu -> Menu( -tearoff => 0, pref $pref ) ;
                $menu -> add ( cascade => -menu => $sm, -label => $_, -underline => 0, pref $pref ) ;
            }
        }
        elsif ($r eq 'ARRAY') {
            my ($l, $c, @more) = @$_ ;
            $sm -> add( ref $l ? @$l : (command => -label => $l, -command => $c, -underline => 0, @more )) ;
        }
        elsif ($r eq 'CODE') {
            $_ -> ( $sm ) ;
        }
        elsif ($r =~ /Menu/) {
            $menu -> entryconfigure( last => -menu => $_ ) ;
        }
    }
}

sub iff($@) {
    my $if = shift ;
    $if ? @_ : ()
}

sub focus_on {
    my $w ;
    $w = ${ shift @_ } if 1 == @_ and 'SCALAR' eq ref $_[0] ;
    $w = shift  while ref $_[0] and $_[0]->can ('name');
    # algo: using the 'while' I can bind it to other widgets
    # kon: last widget takes
    return unless istkwidget $w ;
    $w->focus() ;
    my $p = shift unless ref $_[0] ;
    for ( my $i = 11 ; $i ; -- $i , $w = $w -> parent() ) {
        last if $w eq $mainwindow ;
        return unless istkwidget $w ;
        return eval { $w->raise()
                  } if ref ( $w ) =~ /^(?:MainWindow|Tk::Toplevel)/ ;
        return eval { $w->raise($p)
                  } if $p and $w->name() =~ /^notebook/i ;
    }
}


sub bypass_busy_for_interrupter {

    # Perlon: I'm bypassing the regular busy mechanism, to allow user interrupting
    # waiting for gdb respond (dangerous!!). this will happen only if hitting a
    # key above a certain widget (button).

    # Note: I trust Tk::Widget to check for "exists $w->{Busy}" and
    # "$w->bind('Busy')". MUST VERIFY WHEN UPDATING Tk::Widget

    my $i = shift or die 'maze' ;
    my $w = $mainwindow ;

    $i -> { "Busy" } = ['kludge'] ;
    # keep current pointer and please do not grab

    $w->Tk::bind('Busy','<Any-ButtonPress>',  [\&_busy, Ev('W'), $i] ) ;
    $w->Tk::bind('Busy','<Any-ButtonRelease>',[\&_busy => 0]);
    $w->Tk::bind('Busy','<Any-KeyPress>',     [\&_busy => 1]);
    $w->Tk::bind('Busy','<Any-KeyRelease>',   [\&_busy => 0]);
#     $w->Tk::bind('Busy','<Any-Motion>',       [\&_busy => 0]); what for?
}

sub _busy
{
 my ($w,$f, $i) = @_;
 if    ( $i and $f == $i ) { $Sgdb::CommandPrompt::stopit = 1 }
 elsif ( $f )              { $w->bell }
 $w->break;
}

sub runlocked {

    # Algo: this call back executer is designed for event responding,
    #       therefore return value will be meaningless

    my  $code = shift ;
    ref $code eq 'CODE' or return telme ref ( $code ) || $code ;
    busy ;
    $code -> ( @_ ) ;
    unbusy ;
}

sub gdb_exec_lock {

    busy () ;
    if ( wantarray ) {

        my @array = &Sgdb::CommandPrompt::ex_gdb_exec ;
        unbusy () ;
        return @array ;
    }
    else {
        my $scalar = &Sgdb::CommandPrompt::ex_gdb_exec ;
        unbusy () ;
        return $scalar ;
    }
    # Perlon: maybe in perl 6 there will be an elegant
    # way to run unbusy() at function end without messing
    # up the return value. 'til then...
}

sub telme {                     # this is the debug function. while developing, I would like it
                                #  printing to STDERR, log file will be preferred in the field.

# this is the debug mode. expansive and full info
#    my ($i, $p, $f, $l, $r) ;
#      ($p, $f, $l, $r) = caller ++$i while ($r =~ /telme|^\s*$/ and $i < 5);

    $ENV{ 'SGDBTK_DEBUG' } or return '' ;

    my ($p0, $f0, $l0) = caller ;
    my ($p, $f, $l, $r) = caller 1 ;
    $f0 =~ s!^.*/!! ;
    $f =~ s!^.*/!! ;
    $r =~ s!^.*::!! ;

    print STDERR join ':', $f,$l,$f0,$l0,"($r) ", map { $_ || '' } @_, "\n" ;
    '' ;                        # always return false
}

sub tellog {
    $ENV{PRINTLOG} or return '' ;
    print STDOUT @_, "\n";#, "\n------------------------------------\n" ;
    return '' ;
}

sub telthem {

    warn "@_\n" unless $Tk::VERSION;
    hook_run('telthem', @_) ;
    return ;                    # undef
}

sub telthemloud {

    warn "@_\n" unless $Tk::VERSION;
    hook_run('telthemloud', @_) ;
    return ;                    # undef
}

sub askthem {

    my $top ;
    my $question = shift ;
    if (ref $question) {
        $top = $question -> toplevel() ;
        $question = shift ;
    }
    else {
        $top = $mainwindow ;
    }
    return telme $question unless $top ;
    my @buttons  = @_ ;
    @buttons = ('OK   ', 'Cancel') unless @buttons ;

    my $d = $top -> DialogBox ( -title => 'sgdbtk question',
                                -buttons => \@buttons,
                                # Perlon: first button becomes default
                              ) ;
    $d -> add ( 'Label',
                -text => $question
              ) -> pack ( qw/-side left -padx 2 -pady 2 -anchor nw/ );

    # Perlon: this is the dark side of perl/tk (or at list Tk::Dialog), dialogs
    # structures will stay in memory. this buffer will make sure that only one
    # instance of every question will be created.

    unbusy ;
    # Note: must unbusy this hook before opening dialog boxes to prevent deadlock
    eval { $d -> icon( -image => pref_image( 'swuchChat-16' ) ) } ;

    $d -> Show() ;
}

sub hook_run_lock {

    busy ;
    &hook_run ;
    unbusy ;
}

{
    # HOOKS

    # hooks - allow manipulation of hooks
    # usage:

    #   hook_add ("some_event", [\&my_func, @first_args]) ;
    #   hook_run ("some_event", @more_args );
    #   hook_remove("some_event", \&my_func) ;

my %hooks ;                     # Perlon: This one can be accessed only from the
                                # scope of the next three functions.
                                #   (For this hash, nobody will enter my living
                                #    room because I got a  gun)

sub hook_run  {                 # Order n, skip warnings

    my $hook = shift ;
    $hook = shift while ref $hook ; # must be scalar
    $hook or die "no hook_name" ;

    return telme ("no hooks for $hook") unless exists $hooks{ $hook } ;

    foreach my $func (@{$hooks{ $hook }}) {

        my ($f, @args) = @$func ;
        $f->(@args, @_) ;

    }
    1 ;
}

sub hook_remove  {              # Order 1, make all sanity checks

    my  $hook  = shift  or die "no hook name" ;
    my  $func  = shift  or die "no func ref" ;
    my $ref ;

    return telme ("no such hook: $hook") unless exists $hooks{ $hook };
    if (ref $func eq 'CODE') {
        $ref = $func ;
    }
    elsif (ref $func      eq 'ARRAY' and
           ref $func->[0] eq 'CODE' ) {
        $ref = $func->[0] ;
    }
    else {
        return telme ("bad arguments ", @_) ;
    }

    $hooks{ $hook } = [grep {$_->[0] != $ref} @{$hooks{ $hook }}] ;
    1 ;
}

sub hook_add {                  # Order 1, make all sanity checks

  HOOK_ITEM: while ( @_ ) {

      my $hook = shift  or die "no hook name" ;
      my $func = shift  or die "no func ref" ;
      ref ( $hook ) and return telme 'bad hook name' . ref $hook ;

      my $ref ;
      if     (ref $func eq 'CODE') {
          $ref  = $func ;
          $func = [$func] ;     # single format
      }
      elsif (ref $func      eq 'ARRAY' and
             ref $func->[0] eq 'CODE' ) {
          $ref = $func->[0] ;
      }
      else {
          return telme ("bad arguments ", @_) ;
      }

      foreach my $hooked ( @{$hooks{ $hook } } ) {

          # Algo: restriction: a function can't participate twice in same hook (it
          # doesn't restrict tk callbacks!).

          $hooked->[0] == $ref or next ;
          telme "replace: $hook/$ref" ;
          @$hooked = @$func ;
          next HOOK_ITEM ;
      }

      push @{$hooks{ $hook } }, $func ;
  }
    1 ;
}
}

sub get_full_filename {

    my ($file, $file_1, $file_2) ;

    $file = shift or return ;

                                # is file absolute?
    return $file if $file =~ m{^/} ;
    my $sources = gdb_sources ;

    my $Qfile = "\Q$file" ;
    ($file_1) = grep ( /\b$Qfile$/, @$sources ) ;
    $file_1 ||= $file ;

                                # is file absolute?
    # return $file_1 if $file_1 =~ m{^/} ;

    ($file_2) = $file_1 =~ m/^\.\.\/(.*)/ ;
    $file_2 ||= $file_1 ;

    foreach my $dir ( @Sgdb::ServicePane::source_directories, './' ) {

        # Note: I trust @source_directories not to contain multi lines strings

        $dir =~ /\w/ or next ;
        my ($d, $e) = $dir =~ /^\s*(\S*)\s*\((.*)\)/ ;
        $d =~ s|/$|| if $d;

        if    ( ! $e ) {
            $d ||= $dir ;
            $d =~ s/\s+$// ;
        }
        elsif ( $e eq 'SymFile' ) {
            $file_2 = "../$file_2" unless $file_2 ne $file_1 ;
        }
        # elsif ( $e eq 'Syren' ) {
        # 
        #     $d = $Sgdb::ServicePane::dir_scratch ;
        #     recursive_mkdir $d . '/' . dirname($file_2) ;
        #     my $release = gdb_cached 'syren-v' ; # gdb_exec_quiet('show emc release') || gdb_exec_quiet('show emc release') ;
        #     my $ret = localconfig 'find-syren-file', $d, $file_2, $release ;
        #     telthemloud $ret if $ret and $ret =~ /^Error:/i ;
        # }
        # elsif ( $e eq 'CVS'   ) {
        # 
        #     my $subdir ;
        #     my $s = $Sgdb::ServicePane::dir_scratch ;
        #     if ( $file_2 =~ m|(.*/)| ) {
        # 
        #         $subdir = $1 ;
        #         $subdir = "$s/$subdir" ;
        #         unless (-d $subdir ) {
        # 
        #             recursive_mkdir $subdir ;
        #             telthemloud "mkdir: can't create $subdir: $!" if $! and ! -d $subdir;
        #         }
        #         my $ret = localconfig 'find-cvs-file', $d, $file_2 , $Sgdb::ServicePane::dir_scratch ;
        #         telthem $ret if $ret ;
        #         $d = $s ;
        #     }
        # }
        elsif ( $e eq 'zip' ) {

            telthemloud 'TODO: get sources from zip file' ;
        }
        elsif ( $e eq 'ftp' ) {

            telthemloud 'TODO: get sources from ftp session' ;
        }




        for my $abs ( "$d/$file_2",
                      "$d/$file_1",
                      "$d/$file" ) {

            $abs = absolute ( $abs ) ;
            return $abs if -f $abs ;
        }
    }

    $file ;                     # good luck
                                # NOTE: current dir becomes the LAST default
}

sub absolute {

    my $f = shift or return '' ;
    unless ( $f =~ /^(?:\/|[a-zA-Z]\:)/ ) {
        $f = $ENV{PWD} . "/$f" ;
    }
    $f =~ s!\\!/!g if $^O eq 'MSWin32' ;
    1 while $f =~ s!//!/! or $f =~ s!/[^/]+/\.\./!/! or $f =~ s!/\./!/!  ;
    $f ;
}

sub args {
                                # Note: arg might be regexp
    my $arg = shift or return ;
    $arguments      or return '' ;

    $arguments =~ m/$arg=(.*?)$/m and return $1 ;
    return '' ;
}

sub args_set {

    $arguments .= join "\n", @_, '' ;
}

# General Utilities ###################################################

# common submenus for Text base widgets

sub menu_pop_common_View {      # the next two are here as a service to
                                # Tk::Text objects users.
    my ($t, $m) = @_ ;

    my $w ;
    tie $w, 'Tk::Configure', $t, '-wrap' ;

    foreach my $menu ( ['radiobutton',
                        -label => 'Wrap Word',
                        -variable => \$w,
                        -value => 'word'
                        ],
                       ['radiobutton',
                        -label => 'Wrap Char',
                        -variable => \$w,
                        -value => 'char'
                        ],
                       ['radiobutton',
                        -label => 'Wrap None',
                        -variable => \$w,
                        -value => 'none'
                        ]
                       ) {
        $m -> add ( @$menu ) ;
    }
    $m ;
}

sub menu_pop_common_Edit {

    # NOTE: some of the next Tk methods are undocumented. although not likely, they might
    #  be replaced one day. I will sign the as 'Fragile' .

    my ($t, $m) = @_ ;

    foreach my $menu ( ['command',
                        -label => 'Find',
                        -command => [$t => 'FindPopUp'] # Fragile
                        ],
                       ['command',
                        -label => 'Find Next',
                        -command => [$t => 'FindSelectionNext'] # Fragile
                        ],
                       ['command',
                        -label => 'Find Previous',
                        -command => [$t => 'FindSelectionPrevious'] # Fragile
                        ],
                       ['separator'
                        ],
                       map ({['command',
                              -label => $_,
                              -command => [$t => "clipboard$_"]
                              ]} $t -> clipEvents() ) ,
                       ['separator'
                        ],
                       ['command',
                        -label => 'Select All',
                        -command => [$t => 'selectAll'] # Fragile
                        ],
                       ['command',
                        -label => 'Unselect All',
                        -command => [$t => 'unselectAll'] # Fragile
                        ],

                       ) { $m -> add ( @$menu ) }
    $m ;
}

# history mechanism for Entry base widgets

sub bind_history_mechanism {

    # args: entry, scalar ptr (associated with entry)
    # retval: sub for adding item to history list

    my ($e, $r) = @_ ;
    ref $r eq 'SCALAR' or die "bad ref: " . ref $r  ;

    $e -> bind( "<Up>",   [\&history_up  , $r] ) ;
    $e -> bind( "<Down>", [\&history_down, $r] ) ;
    my $sub = sub {
        my $cmd = shift or return ;
        if(($e -> {sgdblastc} || '') ne $cmd ) {
            $e -> {sgdblastc}        =  $cmd ;
            push @{ $e -> {sgdbhist} }, $cmd ;
        }
        $e -> {sgdbindex} = @{ $e -> {sgdbhist} || [] }
    } ;
    $sub -> (pop @{ $e -> {sgdbhist} }) if 'ARRAY' eq ref $e -> {sgdbhist} ;
    $sub
}

sub history_up {

    my ($e, $r) = @_ ;

    if    ( ! $e -> {sgdbindex} ) {
        # bottom
        $mainwindow -> bell ;
    }
    elsif ( $e -> {sgdbindex} == @{ $e -> {sgdbhist} } ) {
        # first hist
        $e -> {sgdbcurrent} = $$r ;
        $$r = $e -> {sgdbhist}[ -- $e -> {sgdbindex} ] ;
    }
    else {
        # a chain in search
        $$r = $e -> {sgdbhist}[ -- $e -> {sgdbindex} ] ;
    }
}

sub history_down {

    my ($e, $r) = @_ ;

    return unless exists $e -> {sgdbindex} and exists $e -> {sgdbhist} ;

    if    (    $e -> {sgdbindex} == @{ $e -> {sgdbhist} } ) {
        # top
        $mainwindow -> bell ;
    }
    elsif ( ++ $e -> {sgdbindex} == @{ $e -> {sgdbhist} } ) {
        # current
        $$r = $e -> {sgdbcurrent} || '' ;
    }
    else {
        # a chain
        $$r = $e -> {sgdbhist}[ $e -> {sgdbindex} ] ;
    }
}

# search mechanism to Text base widget:
# addition: default binding for KeyPress

sub bind_search_mechanism {

    my ($t, $e, $noebind, $dkp) = @_ ;

    # addition: Entry parameter to focus on when typing in ROText widgets

    # Algo: $t MUST be read-only, and when clicking ascii to ROtext,
    # we probably want to see it elsewhere.

    if ( ref ( $e ) =~ /Entry/ ) {

        # Algo: currently I only support focus on Entry based widgets
        # but it will be easy to expand it to subs and whoknowwhat

        $dkp = [sub { my ($t, $k) = @_ ;
                      return unless length ($k) == 1 and $k =~ /\w/ ;
                      $e -> focus() ;
                      $e -> insert( 'end', $k ) ;
                  } ,
                Ev( 'A' ),
               ] ;
        $t->bind ("<KeyPress>", $dkp ) ;

        unless ($noebind) {
            $e->bind ("<Control-Up>",   [$t => 'yviewScroll', -1, 'units'  ]) ;
            $e->bind ("<Control-Down>", [$t => 'yviewScroll', +1, 'units'  ]) ;
            $e->bind ("<Control-Home>", [$t => 'yviewMoveto',  0           ]) ;
            $e->bind ("<Control-End>",  [$t => 'yviewMoveto',  1           ]) ;
            $e->bind ("<Control-Left>", [$t => 'xviewScroll', -1, 'units'  ]) ;
            $e->bind ("<Control-Right>",[$t => 'xviewScroll', +1, 'units'  ]) ;
            $e->bind ("<Control-Prior>",[$t => 'yviewScroll', -1, 'pages'  ]) ;
            $e->bind ("<Control-Next>", [$t => 'yviewScroll', +1, 'pages'  ]) ;
            $e->bind ("<Control-l>",    [$t => 'yview',  'end'             ]) ;
            $e->bind ("<Meta-Up>",     sub {}) ;
            $e->bind ("<Meta-Down>",   sub {}) ;
        }
    }

    unless ( grep { $_ eq 'e-search'} $t->tagNames()  ) {
        $t -> tagConfigure( 'e-search', pref 'default-e-search-tag' ) ;
        $t -> tagRaise( 'e-search' ) ;
    }

    $t -> bind ("<Control-s>", [\&electric_search_mode, -f => -n => $dkp]) ;
    $t -> bind ("<Control-r>", [\&electric_search_mode, -b => -n => $dkp]) ;
    $t -> bind ("<Control-S>", [\&electric_search_mode, -f => -e => $dkp]) ;
    $t -> bind ("<Control-R>", [\&electric_search_mode, -b => -e => $dkp]) ;
    $t -> bind ("<Meta-Up>",     sub {}) ;
    $t -> bind ("<Meta-Down>",   sub {}) ;

    $t -> bind (        "<4>", [$t => 'yviewScroll', -3, 'units' ]) ; # mouse wheel up
    $t -> bind (        "<5>", [$t => 'yviewScroll', +3, 'units' ]) ; # and down
    $t -> bind (  "<Shift-4>", [$t => 'yviewScroll', -1, 'units' ]) ; # mouse wheel up
    $t -> bind (  "<Shift-5>", [$t => 'yviewScroll', +1, 'units' ]) ; # and down
    $t -> bind ("<Control-4>", [$t => 'yviewScroll', -1, 'page'  ]) ;
    $t -> bind ("<Control-5>", [$t => 'yviewScroll', +1, 'page'  ]) ;
    $t
}

sub electric_search_mode {

    my ($t, $direction, $case, $dkp ) = @_ ;

    $t -> bind ('<KeyPress>',  [\&electric_search, Ev('A'), Ev('K'), $direction, $case, $dkp ] ) ;
    $t -> bind ('<FocusOut>',  [\&electric_search_mode_done, 'FocusOut', $dkp]) ;
    $t -> bind ('<1>'       ,  [\&electric_search_mode_done, 'B'       , $dkp]) ;
    $t -> bind ('<2>'       ,  [\&electric_search_mode_done, 'B'       , $dkp]) ;
    $t -> bind ('<3>'       ,  [\&electric_search_mode_done, 'B'       , $dkp]) ;
    $t -> bind ('<Control-g>', [\&electric_search_mode_done, 'CANCEL'  , $dkp]) ;
    $t -> bind ('<Control-w>', \&electric_search_complete_word ) ;

    electric_search ( $t, '', '', $direction, $case, $dkp ) ;
}

my $search_word ;
my $last_search_word = '' ;
sub electric_search {

    my ($t, $k, $K, $direction, $case, $dkp) = @_ ;
    # telme $k, $K, $direction, $search_word, eval { $t -> index('search') } ;
    my $forw = $direction ne '-b' ;
    my $curr ;

    # user's input
    if ( $K =~ m[^(?: Down | Up  |Left  |Right | Return |
                      Home | End |Prior |Next  | Escape )]xo ) {
        return electric_search_mode_done ( $t, $K, $dkp ) ;
    }
    elsif ( $K eq 'BackSpace' ) {
        chop  $search_word ;
        undef $search_word unless length $search_word ;
    }
    elsif ( $k or $k eq '0') {
        $search_word .= $k ;
    }
    elsif ( $K ) {
        return $t -> break ;    # something ..
    }
    elsif ($search_word and $t -> tagRanges ( 'e-search') ) {
        $curr = $t -> index( 'e-search.first' ) ;
    }                           # $curr means $search_word hadn't changed

    # determine starting point
    if    ( $curr ) {
        $t -> markSet ( 'search' , $forw ? "$curr linestart" : "$curr -1 c" ) ;
                                #                 __ ^__ this linestart fixes a Tk::Text bug
    }
    elsif ( $search_word and length $search_word ) {

    }
    elsif ( $t -> tagRanges( 'sel' ) ) {
        $search_word = $t -> get  ('sel.first', 'sel.last' ) ;
        $t -> markSet ( 'search', 'sel.first' ) ;
    }
    elsif ( defined $search_word ) {
        # second c-s, search is predefined
        $search_word = $last_search_word ;
    }
    else {
        $search_word = '' ;
        $t -> markSet ( 'search', 'insert' ) ;
    }

    unless (length $search_word) { # empty
        return hook_run 'display-in-statusbar', "Search Mode: (use ascii-keys or Ctrl-s/r/S/R/w/g)" ;
    }

    my $loc ;
    while (1) {
        $loc = $t -> search ( $direction,
                              $case,
                              # '-hidden', # otherwise expose tk bug
                              '--',
                              $search_word ,
                              'search',
                              $forw ? 'end' : '1.0'
                            ) ;
        last unless $curr and $loc ;
        if ($forw) {
            last if $t -> compare ($curr, '<', $loc ) ;
            $t -> markSet ( 'search', 'search +1 c' ) ;
        }
        else {
            last if $t -> compare ($curr, '>', $loc ) ;
            $t -> markSet ( 'search', 'search -1 c' ) ;
        }
    }

    my $Search = 'Search ' ;
    $Search   .= 'backward ' if $direction eq '-b' ;
    $Search   .= 'case '     if $case      eq '-e' ;

    if ( $loc ) {

        $t -> tagRemove( 'e-search', '1.0', 'end' ) ;
        $t -> see ( $loc ) ;
        $t -> tagAdd ( 'e-search', $loc, join ' ', $loc, '+', length( $search_word ) , 'c') ;

        hook_run 'display-in-statusbar', "$Search:$search_word" ;
    }
    else {

        hook_run 'display-in-statusbar', "$Search Failed: $search_word" ;
        $t -> bell () ;
        $t -> see ( $t -> tagRanges ( 'e-search' ) ? 'e-search.first' : 'search' ) ;
        $t -> markSet ( 'search' , 'search -1 c' ) ;
    }
    $t -> break ;
}

sub electric_search_mode_done {

    my $t = shift ;
    my $k = shift ;
    $k  ||= '' ;
    my $dkp = shift ;           # default KeyPress

    $last_search_word = $search_word ;
    $search_word = undef ;
#    telme $k ;

    $t -> bind ($_, 'NoOp') for qw(<FocusOut> <1> <2> <3>) ;
    $t -> bind ( "<KeyPress>", $dkp ? $dkp : 'NoOp' ) ;

    hook_run 'display-in-statusbar', '' ;

    eval {
        if    ( $k eq 'CANCEL' ) {

            $t -> markSet ( 'insert' , 'search' ) ;
            $t -> see ( 'insert' ) ;
        }
        elsif ( $k eq 'B' ) {

                                # mouse click, don't change position
        }
        elsif ( $t -> tagRanges ( 'e-search' ) ) {

            $t -> markSet ( 'insert' , 'e-search.first' ) ;
            $t -> see ( 'insert' ) ;
        }
    } ;
    telme $@ if $@ ;

    $t -> tagRemove( 'e-search', '1.0' => 'end' ) ;
    $t -> markUnset( 'search' ) ;
    $t -> break ;
}

sub electric_search_complete_word {

    my $t = shift ;

    my ($start, $end) ;
    if ( $t -> tagRanges( 'e-search' ) ) {

        $start = $t -> index ( 'e-search.first'  );
        $end   = $t -> index ( 'e-search.last +1 c wordend' ) ;
        $t -> tagRemove( 'e-search' , '1.0' => 'end') ;
    }
    else {

        $start = $t -> index ( 'search' ) ;
        $end   = $t -> index ( 'search wordend' ) ;
    }
    $t -> tagAdd ( 'e-search', $start, $end ) ;
    $search_word = eval {$t -> get ( 'e-search.first' => 'e-search.last' )} ;
    $search_word ||= '' ;
}


my ($filedialogopen, $filedialogsave) ;
sub find_file_win {
#          1. open/save 0/1
#          2. title
#          3. filename
#          4  more...
}

my $filedialog ;
sub find_file {

#      params :
#          1. open/save 0/1
#          2. title
#          3. filename
#          4  more...

#    return &find_file_win if $^O eq 'MSWin32' ;
    return telthemloud "internal error: $@" unless require Sgdb::Tk::JBrowseEntry ;
    return telthemloud "internal error: $@" unless require Sgdb::Tk::JFileDialog ;
    $filedialog ||= $mainwindow -> JFileDialog ( # -ShowAll => 1 ,
#                                                 -HistFile => pref ('last-filedialog-hist-file') || "$ENV{HOME}/.sgdbFDhist",
                                                );

    my $create = shift ;
    if    ( $create eq 'open' )   { $create = 0 }
    elsif ( $create eq 'save' )   { $create = 1 }
    elsif ( $create eq 'config' ) { return $filedialog -> configure ( @_ ) }

    my $title = shift ;
    $title ||= 'find file..' ;

    my $filename = shift || '';
    my ($dir, $file) = $filename =~ m!^(.*)/(.*)$! ;
    $dir  ||= $ENV{HOME} ;
    $file ||= '' ;

    $dir = absolute( $dir ) ;
    unless ( -d $dir ) {
        telthemloud ( "$dir: not a directory" ) ;
        $dir = '' ;
    }

#     my @p = ( -title => $title ,
#               -initialdir => $dir,
#               -initialfile => $file,
#               # todo: file extentions
#             ) ;
#     return ( $create ?
#              $mainwindow -> getSaveFile( @p ) :
#              $mainwindow -> getOpenFile( @p )
#            )
    $filedialog -> Show ( -Title  => $title ,
                          -Create => $create,
                          -Path   => $dir ,
                          -File   => $file,
#                           -HistFile => pref ('last-filedialog-hist-file') || "$ENV{HOME}/.sgdbFDhist",
                          -FPat   => '*',
                          @_
                          ) ;
}

sub getfilename {

    my $f = shift or return ;

    return $f unless 0 <= index $f, '~' ;

    my $foo = $f ;

    if ( $ENV{HOME} and
         $foo =~ s{~(/|\\)}($ENV{HOME} . $1 )e ) {
        return $foo ;
    }
    # let the shell try ..
    chomp ( $foo = `ls -d $f` ) ;
    return  $foo if $foo and $foo =~ /\w[^\n]*$/s ;
    $f =~ s{~(/|\\)}($ENV{HOME} . $1 )e if $ENV{HOME} ;
    $f ;
}

sub tab_complete_filename {

    my $e = shift ;
    my $path = $e -> get ;
    my $calbk = shift ;

    $path .= '*' if $path !~ /\*/;

    my @res = glob $path ;

    for (@res)
      { $_ .= '/' if -d }

    if    ( @res == 0 ) {
        $e -> bell ;
    }
    elsif ( @res == 1 ) {

        ($path, @res) = @res ;
    }
    else {

        my $i = index $path, '*'  ;
        $i = length ( $path ) if $i < 0 ;

      IINCREASE: while ( 1 ) {

            last if $i >= length $res[0]  ;
            my $char = substr (  $res[0], $i, 1 ) ;

            foreach my $r ( @res ) {

                last IINCREASE if length( $r ) <= $i ;
                last IINCREASE if substr( $r, $i, 1) ne $char ;
            }
            $i ++ ;
        }
        $path = substr $res[0], 0, $i ;
    }

    if (@res ) {

        #         hook_run 'show-completions', $res ;
        my $m = $e -> Menu ( -tearoff => 0,
                             pref ('file-completion-pop-menu'),
                           ) ;
        $m -> delete ( 0, 'end' ) ;
        my $sub = sub { $e -> delete( 0, 'end' ) ;
                        $e -> insert( 0, shift ) ;
                    } ;
        for my $res ( @res ) {
            $m -> add ( command  =>
                        -label   => $res ,
                        -command => [$sub, $res ],
                      ) ;
        }
        $m -> Post ( $e -> rootx(),
                     $e -> rooty() + $e -> height()
                   );
    }

    $path =~ s/[\*\@]$// ;

    $e -> delete ( 0, 'end' ) ;
    $e -> insert ( 0, $path ) ;
    $e -> break  () ;
}

sub tab_complete_gdb_command {

    my ( $e ) = grep { ref } @_ ;
    my $pre   = join ' ', grep { ! ref } @_ ;
    my $cmd   = $e -> get || '' ;

    return unless $cmd =~ /\w/ ;

    busy ;
    my $res = gdb_exec_quiet "complete $pre $cmd" ;
    unbusy ;
    $res =~ s/^$pre +//gm ;
    my @res = split /\n/, $res || '' ;

    if    ( @res == 0 ) {

        $e ->bell ;
    }
    elsif ( @res == 1 ) {

        $cmd = $res[0] ;
        $res = '' ;
    }
    else {

        my $i = length ($cmd) -1 ;
        $cmd = shift @res ;

      IINCREASE: while ( $i ++ ) {

            my $char = substr ( $cmd, $i, 1 ) ;

            foreach my $r ( @res ) {

                last IINCREASE if length( $r ) == $i ;
                last IINCREASE if substr( $r, $i, 1) ne $char ;
            }
#            last if grep {$i >= length($_) or substr($_, $i, 1) ne $char} @res ;
        }
        $cmd = substr $cmd, 0, $i;
    }

    hook_run 'show-completions', $res ;

    $e -> delete (0, 'end') ;
    $e -> insert (0, $cmd );
    $e -> break() ;
}

sub menu_pop_NB_Raise {
    my $m = shift or return telme 'no menu' ;
    my $w = shift || $m ;
    my $sm = $m -> Menu ( -tearoff => 0,
                          pref 'pop-menu' ,
                        ) ;
    configure $sm -postcommand => [\&menu_pop_populate_notebook, $sm, $w] ;
    $sm ;
}

sub menu_pop_populate_notebook {

    my ($m , $w ) = @_ ;
    $m -> delete ( 0 => 'end' ) ;
    my $sanity = 11 ;
    my $nb ;
    while ( -- $sanity ) {
        $w -> name() eq 'notebook' and $nb = $w and last ;
        $w = $w -> parent() or last ;
    }
    $nb or return telme 'no notebook' ;
    foreach my $name ( sort $nb -> pages() ) {
        $m -> add ( 'command',
                    -label => $name,
                    -command => [$nb, 'raise', $name],
                    ) ;
    }
}

sub please_close_me {
    my $w = shift ;
    my $tp = $w->toplevel() ;
    my $nb = $w ;
    my $sanity = 11 ;
    while (-- $sanity ) {
        if ($nb -> name() eq 'notebook') {
            my $up = $nb -> raised(     ) or return telme "nothing up" ;
            return   $nb -> delete( $up ) ;
        }
        $nb =  $nb -> parent() or last;
        $nb == $tp and last ;
    }
    $tp -> destroy() ;
}

sub save_Text_data_as {

    my $t = shift ;
    istkwidget $t or return telme "bad text" ;
    my $pref  = shift || 'last-text-save-filename' ;
    my $title = shift || 'Save Data as ..' ;

    my $file  = find_file ( 1,
                           $title,
                           pref ( $pref ) || '' ,
                           ) ;
    $file or return ;

    open  FILE, ">$file" or return telthemloud "cannot open file '$file': $!" ;
    print FILE $t -> get( '1.0' => 'end' ) ;
    close FILE ;
    pref_set $pref, $file ;
    $file ;
}

sub info_line_lookup {

    my ($t, $fn, $zx, $clicked) = @_ ;
    my $c = $t -> index ( 'current' ) ;

    return unless gdb_cached( 'file' ) ;

    my ($w, $start, $end, $tag ) ;

    for my $i ( 0 .. 5 ) {
        # $start = $t -> index( "$c -$i c wordstart" ) ;
        # $end   = $t -> index( "$c -$i c wordend"   ) ;
        # $w = $t -> get ("$start" => "$end") ;
        ($w, $start, $end) = text_current_word( $t, "$c -$i c" );
        last if $w and $w =~ /\w/ ;
    }
    if ( ! $w ) {}
    elsif ($w =~ /^0x[\da-fA-F]+$/ )        { $w =   "*$w" }
    elsif ( $zx and $w =~ /^[\da-fA-F]+$/ ) { $w = "*0x$w" }
    elsif ( $fn ) {
        $tag = $t -> tagNames( $start ) if 1 < length $fn ;
        if ('ARRAY' eq ref $tag ) {
            unless (grep {$_ eq $fn} @$tag) { $w = '' }
        }
        elsif ($tag and $tag ne $fn )       { $w = '' }
    }
    else                                    { $w = '' }

    return unless $w ;

    if ( $clicked ) { # and pref 'highlight-info-line-clicked' ) {
        $t -> tagRemove( $clicked , '1.0', 'end' ) ;
        $t -> tagAdd ( $clicked, $start, $end ) ;
    }

    gdb_exec_lock( "info line $w" ) ;
}

sub save_geometry {
    return unless pref 'last-geometry-save-at-exit' ;
    my ($last, $win, $file) = @_ ;
    pref_set $last, $win->geometry(), $file ;
}

sub window_geometry($$) {
    my ($name, $win) = @_ ;
    return unless istkwidget $win ;
    my $file = 'recent/' . ($ENV{HOSTNAME} || $ENV{HOST} || $ENV{HOSTTYPE} || 'localhost') . '/' . ( $ENV{DISPLAY} || '0' ) ;
    my $last = "last-geometry-$name" ;
    $win -> geometry ( pref ( $last, $file ) || '600x400+40+40' ) ;
    $win -> OnDestroy ([\&save_geometry, $last, $win, $file] ) ;
}

sub bind_font_resize {
    my $w = shift ;
    $w -> bind ( '<Control-plus>',         [\&change_font_size,  1, $w] ) ;
    $w -> bind ( '<Control-KP_Add>',       [\&change_font_size,  1, $w] ) ;
    $w -> bind ( '<Control-minus>',        [\&change_font_size, -1, $w] ) ;
    $w -> bind ( '<Control-KP_Subtract>',  [\&change_font_size, -1, $w] ) ;
    $w
}

my %create_window ;
sub create_window {
    my ($package, $title, $name, $image, $pack, @params) = @_ ;
    if (istkwidget
        $create_window{$name} ) {
        $create_window{$name} -> raise() ; # $mainwindow ) ;
        $create_window{$name} -> focus() ;
        return 0;
    }

    unless (eval {$package -> can ('new') } ) {
        my $p = $package ;
        $p =~ s/::/\//g  ;
        $p .= '.pm' ;
        return telthemloud "can't load $package" unless require $p;
    }
    my $w = $create_window{$name} = $mainwindow -> Toplevel() ;
    $w -> title( $title ) ;
    window_geometry $name, $w ;
    $w -> Icon( -image => pref_image( $image || $name ) ) ;
    bind_font_resize $w ;
    change_font_size $w ;
    my $t = $package -> new ( $w, @params ) ;
    $t -> pack (qw/-fill both -expand 1/) if $pack ;
    ''
}

sub get_recent {
    my @r = split /\s*\;\s*/, pref @_ ;
    wantarray ? @r : shift @r
}

sub set_recent {
    my ($pr, $rc, $fl) = @_ ;
    telme $pr, $rc, $fl, my $recent = pref $pr, $fl ;
    my  @recent = ($rc, grep {$_ ne $rc} split /\s*\;\s*/, $recent );
    pop @recent if @recent > ( pref ( "max-$pr" ) || 20 );
    telme @recent ;

    pref_set $pr, join (';', @recent), $fl ;
}

sub callbacker {
    no strict 'subs' ;
    my ($obj, $cb, @p) = @_ ;

    if ('ARRAY' eq ref $cb) {
        ($cb, my @cb) = @$cb ;
        return $obj->$cb  (@cb, @p) if ref $obj and       not ref $cb;
        return $cb->($obj, @cb, @p) if ref $obj and 'CODE' eq ref $cb;
        return $cb->(      @cb, @p) if              'CODE' eq ref $cb;
        return telme "bad call", @_ ;
    }

    return $cb->($obj, @p) if ref $obj and 'CODE' eq ref $cb ;
    return $cb->(      @p) if              'CODE' eq ref $cb ;
    return $obj->$cb  (@p) if ref $obj and $cb and not ref $cb;
    return telme "bad call:", @_ ;
}

sub array_eq {
    my ($a, $b) = @_ ;
#     return telme "bad ref" unless 'ARRAY' eq ref $a and 'ARRAY' eq ref $b ;
    return '' unless @$a == @$b ;
    for my $i ( 0 .. @$a ) {
        defined $a->[$i]  or defined $b->[$i] or next ;
        return '' unless $a->[$i] eq $b->[$i]
    } 1
}

# sub grr($$) { ( -column => shift, -row => shift, -padx => 1, -sticky => 'ew' ) }

# our ($slc_cred, $slc_pass) = ($ENV{SLC_CRED} || '', $ENV{SLC_PASS} || '');
# sub slc_weekly {
#     my ($c, $p ) = &Sgdb::LocalConfig::slc_weekly ;
#     return telthemloud "can't determine weekly credential" unless $c and $p ;
#     ($slc_cred, $slc_pass) = ($c, $p) ;
# }

my $http_get ;
sub http_get(@) {
    # returns content, or undef with $@ error message
    require LWP or return telthemloud "http_get: can't use LWP" ;
    $http_get ||= new LWP::UserAgent ;
    my $url = shift ;
    $url =~ /^http/ or $url = "http://$url" ;
    eval {
        my $res = $http_get -> get ( $url, @_ );
        return $res -> content() if $res -> is_success() ;
        die    $res -> status_line() ;
    };
}

# hook_add ( 'new-chat-window' => [\&create_window, 'Swuch::Chat', 'Swuch Chat', 'swuch-chat'],
#            'new-chat-target' => sub {},
#          ) ;

sub get_a2l {
    my $a = gdb_cached 'Addr2Line' ;
    return $a if $a ;
    use Sancho::Addr2Line ;

    my $f = gdb_cached 'file' ;
    return unless $f ;
    gdb_cached 'Addr2Line', new Addr2Line $f, localconfig 'addr2line' ;
}

sub text_current_word($$) {
    my ($t, $c) = @_;
    my $re = qr/\W/;
    my $s = $t->search (-regexp => -backward => $re, $c, "$c linestart" ) ;
    $s = $s ? $t->index("$s+1c") : $c ;
    my $e = $t->search (-regexp =>  -forward => $re, $c, "$c lineend"   ) ;
    $e ||= $t->index("$c+1c") ;
    my $ret = $t->get($s, $e);
    return ($ret, $s, $e) if wantarray ;
    return ($ret);
}

'end'
